home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d14
/
baswind8.arc
/
CALENDAR.SUB
< prev
next >
Wrap
Text File
|
1990-09-14
|
7KB
|
250 lines
'
'
'******************************************************************************
' Function : CALENDAR *
' *
' Purpose: *
' *
' *
' Results: *
' *
' Usage : *
' *
' *
' Date Written : 09/01/90 - Date Tested: 09/01/90 - Author: James P Morgan *
' Date Modified: - : - : *
'-----------------------------------------------------------------------------*
' NOTE: *
'******************************************************************************
' *
' SUB PROGRAM NAME (PARAMETERS) STATIC/RECURSIVE *
'-----------------------------------------------------------------------------*
' *
SUB CALENDAR(MONTH%,YEAR%,QUADRANT$,FORE%,BACK%,SHADOW%,RETURN.CODE%) STATIC
DEFINT A-Z
'DIMENSION ARRAY AND FILL WITH DATA
'
DIM LKUP$(12,2)
'INITIALIZE LOOKUP ARRAY FOR DAYS IN MONTH%
RETURN.CODE%=0
SETQUAD.RETURN.CODE%=0
VIDEO.RETURN.CODE%=0
LKUP$(1,1)="January "
LKUP$(1,2)="31"
LKUP$(2,1)="February "
LKUP$(2,2)="28"
LKUP$(3,1)="March "
LKUP$(3,2)="31"
LKUP$(4,1)="April "
LKUP$(4,2)="30"
LKUP$(5,1)="May "
LKUP$(5,2)="31"
LKUP$(6,1)="June "
LKUP$(6,2)="30"
LKUP$(7,1)="July "
LKUP$(7,2)="31"
LKUP$(8,1)="August "
LKUP$(8,2)="31"
LKUP$(9,1)="September"
LKUP$(9,2)="30"
LKUP$(10,1)="October "
LKUP$(10,2)="31"
LKUP$(11,1)="November"
LKUP$(11,2)="30"
LKUP$(12,1)="December"
LKUP$(12,2)="31"
IF (MONTH%<1) OR (MONTH%>12) THEN
RETURN.CODE%=-2
GOTO CALENDAR.DONE
END IF
IF YEAR%<0 THEN
RETURN.CODE%=-3
GOTO CALENDAR.DONE
END IF
'
'If Quadrant is in ROW:COL format, extract Row and Column
IF INSTR(QUADRANT$,":")<>0 THEN
GOSUB CALENDAR.GETORD
GOTO CALENDAR.GO1
END IF
'Determine Position based on Quadrant Parameter and size of menu
QUADRANT%=VAL(QUADRANT$)
IF QUADRANT% <0 OR QUADRANT% >4 THEN
QUADRANT%=0
END IF
CALL SETQUAD(QUADRANT,CROW,CCOL,0,0,SETQUAD.RETURN.CODE%)
ULR%=CROW%-4
ULC%=CCOL%-12
LRR%=ULR%+9
LRC%=ULC%+21
'Create Window for Calendar
CALENDAR.GO1:
FRAME%=4
LABEL$=""
CALL MAKEWIND(ULR%,ULC%,LRR%,LRC%,FRAME%,FORE%,BACK%,GROW%,SHADOW%,LABEL$,MAKEWIND.RETURN.CODE%)
GOSUB CALENDAR.DISPCAL
GOTO CALENDAR.DONE
'
CALENDAR.DISPCAL:
GOSUB CALENDAR.NUMDAYS
FLEAP%=0
IF YEAR% MOD 400=0 THEN
GOTO CALENDAR.LEAP
END IF
IF YEAR% MOD 100=0 THEN
GOTO CALENDAR.NOLEAP
END IF
IF YEAR% MOD 4<>0 THEN
GOTO CALENDAR.NOLEAP
END IF
CALENDAR.LEAP:
FLEAP%=1
IF ND!=28 THEN
ND!=29
END IF
'
CALENDAR.NOLEAP:
YEAR!=YEAR%
Y1!=365*YEAR!+INT((YEAR!-1)/4)
Y2!=INT(.75*(INT((YEAR!-1)/100)+1))
YDAYS!=Y1!-Y2!
MDAYS!=0
FOR I%=1 TO MNUM%-1
MDAYS!=MDAYS!+VAL(LKUP$(I%,2))
NEXT
DAYS!=YDAYS!+MDAYS!+1
IF FLEAP%=1 AND MONTH%>2 THEN
DAYS!=DAYS!+1
END IF
DW!=DAYS!+INT(-DAYS!/7)*7+6
MSG$=STRING$((LRC%-ULC%)," ")
ATTR%=(BACK% AND 7) * 16 + FORE%
COL%=ULC%
PAGE%=0
FOR I%=(ULR%+4) TO LRR%
CALL FASTPRT(MSG$,I%,COL%,ATTR%,VIDEO.RETURN.CODE)
NEXT
COLOR FORE%,BACK%
LOCATE ULR%,ULC%
PRINT " ";LKUP$(MONTH%,1);
PRINT STRING$(((LRC%-ULC%)-LEN(LKUP$(MONTH%,1))-6)," ");
PRINT YEAR!;
LOCATE ULR%+1,ULC%
PRINT STRING$(LRC%-ULC%+1,205)
LOCATE ULR%+2,ULC%+1
PRINT "S M T W T F S"
CS!=1
FOR R%=ULR%+4 TO ULR%+10
C1!=0
FOR C%=ULC%+1 TO ULC%+19 STEP 3
C1!=C1!+1
CD!=CS!-DW!
IF CD!<1 OR CD!>ND! THEN
GOTO CALENDAR.LAST
END IF
CD$=STR$(CD!)
CD$=RIGHT$(CD$,LEN(CD$)-1)
ATTR%=(BACK% AND 7)*16 + FORE%
PAGE%=0
CALL FASTPRT(CD$,R%,C%,ATTR%,VIDEO.RETURN.CODE%)
CALENDAR.LAST:
CS!=CS!+1
NEXT
NEXT
RETURN
'
'DETERMINE NUMBER OF DAYS IN MONTH%
'
CALENDAR.NUMDAYS:
MNUM%=MONTH%
ND!=VAL(LKUP$(MONTH%,2))
RETURN
'
CALENDAR.GETORD:
QUADRANT$=LTRIM$(QUADRANT$)
QUADRANT$=RTRIM$(QUADRANT$)
COLON.LOC=INSTR(QUADRANT$,":")
IF COLON.LOC=1 THEN
QUADRANT$="01"+QUADRANT$
COLON.LOC=3
END IF
ULR%=VAL(LEFT$(QUADRANT$,COLON.LOC-1))
IF (ULR%<1) OR (ULR%>24) THEN
ULR%=2
END IF
IF COLON.LOC=LEN(QUADRANT$) THEN
QUADRANT$=QUADRANT$+"00"
END IF
ULC%=VAL(MID$(QUADRANT$,COLON.LOC+1))
IF (ULC%<1) OR (ULC%>80) THEN
GOSUB CALENDAR.CENTER.ON.THE.LINE
END IF
QUADRANT.ROW$=STR$(ULR%)
QUADRANT$="0"+RIGHT$(QUADRANT.ROW$,LEN(QUADRANT.ROW$)-1)+":"
QUADRANT.COL$=STR$(ULC%)
QUADRANT$=QUADRANT$+"0"+RIGHT$(QUADRANT.COL$,LEN(QUADRANT.COL$)-1)
LRR%=ULR%+9
LRC%=ULC%+21
RETURN
'
CALENDAR.CENTER.ON.THE.LINE:
TEMP.ULC=40-(20/2)
IF (ULC<2) THEN
TEMP.ULC=2
END IF
ULC=TEMP.ULC
RETURN
'
CALENDAR.DONE:
ERASE LKUP$
CD$=""
MSG$=""
LABEL$=""
END SUB